home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-11 / rlib.zip / RL_BARME.PRG < prev    next >
Text File  |  1993-01-04  |  7KB  |  198 lines
  1. * Function..: BARMENU
  2. * Author....: Richard Low
  3. * Syntax....: BARMENU( row, options [,columns [,start [,altkeys [,exitkeys ;
  4. *                      [,prompts [,prompt_row [,colors ] ] ] ] )
  5. * Returns...: Number of array element option picked, or 0 if escape pressed.
  6. * Parameters: row       - Numeric row for bar menu to appear
  7. *             options   - Array of bar menu option choices
  8. *             columns   - Optional array of column numbers for each option
  9. *             start     - Optional starting array element number
  10. *             altkeys   - Optional list of alternate selection keys
  11. *             exitkeys  - Optional list of keys to cause a 0 return value exit
  12. *                         Pass a null string skip (default = escape)
  13. *                         Pass .F. to disable 0 return value exit altogether
  14. *             prompts   - Optional array of menu option messages
  15. *             promptrow - Optional row number on which these messages appear
  16. *             colors    - Optional array of colors to use in menu
  17. * Notes.....: Optional parameters are not required, but if you wish to skip
  18. *             an optional parameter, you must pass a dummy value.  The best
  19. *             dummy value to use is a null string '' (set up a memvar named
  20. *             dummy where dummy = '').
  21.  
  22. FUNCTION BARMENU
  23.  
  24. PARAMETERS p_row, p_options, p_cols, p_choice, p_altkeys, p_exitkeys,;
  25.            p_prompts, p_prmtrow, p_colors
  26.  
  27. PRIVATE f_autocol, f_nextcol, f_prompton, f_incolor, f_canexit,;
  28.         f_junk, f_x, f_lkey, f_display, f_menubar, f_barline, f_selected
  29.  
  30. *-- if the public variable <rlib_fast> exists and is logical
  31. *-- skip parameter checking
  32.  
  33. IF .NOT. TYPE('rlib_fast') = 'L'
  34.  
  35.    *-- make sure options array specified
  36.    IF TYPE('p_options') != 'A'
  37.       RETURN 0
  38.    ENDIF
  39.  
  40.    *-- if first parameter is numeric
  41.    IF TYPE('p_row') = 'N'
  42.       *-- make sure it is in range, if not, default to row
  43.       p_row = IF( p_row < 0 .OR. p_row > 24, 1, p_row )
  44.    ELSE
  45.       *-- else default to row number one
  46.       p_row = 1
  47.    ENDIF
  48.  
  49.    *-- if p_choice specified make sure it is in range, else default to option 1
  50.    p_choice = IF( TYPE('p_choice') = 'N', MIN(MAX(p_choice,1),LEN(p_options)), 1 )
  51.  
  52. ENDIF
  53.  
  54. *-- if colums array not specified, build columns automatically
  55. IF TYPE('p_cols') = 'A'
  56.    f_autocol = .F.
  57. ELSE
  58.    f_autocol = .T.
  59.    *-- set up array to hold columns
  60.    DECLARE p_cols[ LEN(p_options) ]
  61. ENDIF
  62.  
  63. *-- messages displayed only if parm is of type array
  64. f_prompton = ( TYPE('p_prompts') = 'A' )
  65.  
  66. *-- messages displayed on line 24 unles otherwise specified
  67. p_prmtrow = IF( TYPE('p_prmtrow') = 'N', p_prmtrow, 24 )
  68.  
  69. *-- save incoming color
  70. STORE SETCOLOR() TO f_incolor
  71.  
  72. *-- use <color array> if it is an array AND it has at least 5 elements
  73. IF IF( TYPE('p_colors') = 'A', IF(LEN(p_colors) >= 5, .T., .F.) , .F. )
  74.    f_display  = p_colors[1]                    && C - display color
  75.    f_menubar  = p_colors[2]                    && C - menu bar color
  76.    f_barline  = p_colors[4]                    && C - menu bar line background color
  77.    f_selected = p_colors[5]                    && C - selected option color
  78. ELSE
  79.    STORE SETCOLOR() TO f_display, f_barline
  80.    f_menubar  = GETPARM(2,f_incolor)
  81.    f_selected = BRIGHT()
  82. ENDIF
  83.  
  84. *-- clear the bar menu line and set the background color
  85. SETCOLOR(f_barline)
  86. @ p_row,0
  87.  
  88. *-- display options and build a list of first letter pick keys
  89. f_junk = ''
  90. SETCOLOR(f_display)
  91.  
  92. IF f_autocol
  93.    *-- if auto building columns, start at column 0
  94.    f_nextcol = 0
  95.    FOR f_x = 1 TO LEN(p_options)
  96.       p_cols[f_x] = f_nextcol                                 && assign column number
  97.       @ p_row,p_cols[f_x] SAY p_options[f_x]                  && say option
  98.       f_nextcol = COL() + 2                                   && next column
  99.       f_junk = f_junk + SUBSTR( LTRIM(p_options[f_x]),1,1 )
  100.    NEXT f_x
  101. ELSE
  102.    FOR f_x = 1 TO LEN(p_options)
  103.       @ p_row,p_cols[f_x] SAY p_options[f_x]
  104.       f_junk = f_junk + SUBSTR( LTRIM(p_options[f_x]),1,1 )
  105.    NEXT f_x
  106. ENDIF
  107.  
  108. *-- now add any alternate pick keys passed as parameters to the list, if any
  109. p_altkeys = IF( TYPE('p_altkeys') = 'C', f_junk + p_altkeys, f_junk )
  110.  
  111. *-- if a Logical was passed in place of exit keys, disable exit feature
  112. f_canexit = IF( TYPE('p_exitkeys') = 'L', p_exitkeys, .T. )
  113.  
  114. *-- see if any exit keys were passed (and not empty), else default to Escape
  115. p_exitkeys = IF( TYPE('p_exitkeys') = 'C', p_exitkeys, CHR(27) )
  116. p_exitkeys = IF( .NOT. EMPTY(p_exitkeys),  p_exitkeys, CHR(27) )
  117.  
  118. DO WHILE .T.
  119.  
  120.    *-- display current selection
  121.    SETCOLOR(f_menubar)
  122.    @ p_row,p_cols[p_choice] SAY p_options[p_choice]
  123.  
  124.    *-- if message prompts are on, clear row and display in previous color
  125.    IF f_prompton
  126.       SETCOLOR(f_incolor)
  127.       @ p_prmtrow,0
  128.       @ p_prmtrow,0 SAY p_prompts[p_choice]
  129.    ENDIF
  130.  
  131.    *-- reset display color
  132.    SETCOLOR(f_display)
  133.  
  134.    *-- wait for a key
  135.    f_lkey = INKEY(0)
  136.  
  137.    DO CASE
  138.  
  139.       CASE f_lkey = 4 .OR. f_lkey = 32
  140.          *-- Right Arrow or Space Bar
  141.          @ p_row,p_cols[p_choice] SAY p_options[p_choice]
  142.          p_choice = IF( p_choice = LEN(p_options), 1, p_choice + 1 )
  143.  
  144.       CASE f_lkey = 19 .OR. f_lkey = 8
  145.          *-- Left Arrow or Back Space
  146.          @ p_row,p_cols[p_choice] SAY p_options[p_choice]
  147.          p_choice = IF( p_choice = 1, LEN(p_options), p_choice - 1 )
  148.  
  149.       CASE f_lkey = 1
  150.          *-- Home Key
  151.          @ p_row,p_cols[p_choice] SAY p_options[p_choice]
  152.          p_choice = 1
  153.  
  154.       CASE f_lkey = 6
  155.          *-- End key
  156.          @ p_row,p_cols[p_choice] SAY p_options[p_choice]
  157.          p_choice = LEN(p_options)
  158.  
  159.       CASE f_lkey = 13
  160.          *-- Enter key
  161.          EXIT
  162.  
  163.       CASE UPPER(CHR(f_lkey)) $ p_altkeys
  164.          @ p_row,p_cols[p_choice] SAY p_options[p_choice]
  165.          f_x = 1
  166.          p_choice = 0
  167.          DO WHILE p_choice = 0
  168.             p_choice = AT(UPPER(CHR(f_lkey)),SUBSTR(p_altkeys,f_x,LEN(p_options)))
  169.             f_x = f_x + LEN(p_options)
  170.          ENDDO
  171.          EXIT
  172.  
  173.       CASE f_canexit
  174.          IF UPPER(CHR(f_lkey)) $ p_exitkeys
  175.             *-- Escape request
  176.             p_choice = 0
  177.             EXIT
  178.          ENDIF
  179.  
  180.    ENDCASE
  181. ENDDO
  182.  
  183. *-- display selected option in selected color
  184. IF p_choice > 0 .AND. p_choice <= LEN(p_options)
  185.    SETCOLOR(f_selected)
  186.    @ p_row,p_cols[p_choice] SAY p_options[p_choice]
  187. ENDIF
  188.  
  189. *-- restore original color
  190. SETCOLOR(f_incolor)
  191.  
  192. *-- if messages are on, clear the message line
  193. IF f_prompton
  194.    @ p_prmtrow,0
  195. ENDIF
  196.  
  197. RETURN (p_choice)
  198.